home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PBLIB1
/
UNITS
/
MISCPTIM.INC
< prev
next >
Wrap
Text File
|
1994-02-17
|
7KB
|
248 lines
{SECTION DateToJulian }
Function DateToJulian(Date : DateRec) : REAL;
{ Note: This routine adapted from "Turbo Pascal Program Library", by
Tom Rugg and Phil Feldman (Que Books, 1986).- via TUG }
var TMonth : REAL;
begin
WITH Date DO
begin
TMonth := int((Month - 14.0) / 12.0);
DateToJulian := Day - 32075.0
+ int(1461.0 * (Year + 4800.0 + TMonth) / 4.0)
+ int(367.0 * (Month - 2.0 - TMonth * 12.0) / 12.0)
- int(3.0 * int((Year + 4900.0 + TMonth) / 100.0) / 4.0)
end
end;
{SECTION JulianToDate }
Procedure JulianToDate(Julian : REAL; var Date : DateRec);
{ Note: This routine adapted from "Turbo Pascal Program Library", by
Tom Rugg and Phil Feldman (Que Books, 1986).- via TUG }
var Temp1 : REAL;
Temp2 : REAL;
begin
WITH Date DO
begin
Temp1 := Julian + 68569.0;
Temp2 := int(4.0 * Temp1 / 146097.0);
Temp1 := Temp1 - int((146097.0 * Temp2 + 3.0) / 4.0);
Year := trunc(4000.0 * (Temp1 + 1.0) / 1461001.0);
Temp1 := Temp1 - int(1461.0 * Year / 4.0) + 31.0;
Month := trunc(80.0 * Temp1 / 2447.0);
Day := trunc(Temp1 - int(2447.0 * Month / 80.0));
Temp1 := int(Month / 11.0);
Month := trunc(Month + 2.0 - 12.0 * Temp1);
Year := trunc(100.0 * (Temp2 - 49.0) + Year + Temp1)
end
end;
{SECTION DaysBetweenPTimes }
Function DaysBetweenPTimes(PT1, PT2 : PTime) : longint;
begin
DaysBetweenPTimes := trunc(PTimeToJulian(PT2) - PTimeToJulian(PT1));
end;
{SECTION DaysBetweenDBaseDates }
Function DaysBetweenDBaseDates(dt1,dt2 : string) : integer;
var d : integer;
pt1,pt2 : PTime;
begin
d := 0;
pt1 := DBaseToPTime(dt1);
pt2 := DBaseToPTime(dt2);
d := DaysBetweenPTimes(pt1,pt2);
DaysBetweenDBaseDates := d;
end;
{SECTION DaysInMonth }
Function DaysInMonth(month, year : integer) : byte;
var d : byte;
begin
case month of
1,3,5,7,8,10,12 : d := 31;
4,6,9,11 : d := 30;
2 : begin
if (year mod 4) = 0 then d := 29
else d := 28;
end;
else d := 31;
end;
DaysInMonth := d;
end;
{SECTION DBaseToPTime }
Function DBaseToPTime(s : string) : PTIME; { 'yyyymmdd' -> longint }
var PT : PTime;
dt : datetime;
dd,mm,yy : integer;
begin
dt.year := StrInt(copy(s,1,4));
dt.month := StrInt(copy(s,5,2));
dt.day := StrInt(copy(s,7,2));
PackTime(dt,PT);
DBaseToPTime := PT;
end;
{SECTION FmtPDateStr }
Function FmtPDateStr(PT : PTime) : string;
var d : DateTime; { DOS }
var temp : string[8];
begin
UnPackTime(PT,d);
temp := FmtYMD(d.year,d.month,d.day);
FmtPDateStr := temp;
end;
{SECTION FmtPtimeStr }
Function FmtPTimeStr(PT : PTime) : string;
var d : DateTime; { DOS }
var temp : string[14];
begin
UnPackTime(PT,d);
temp := FmtYMD(d.year,d.month,d.day)+' '+FmtHMS(d.hour,d.min,d.sec);
FmtPTimeStr := temp;
end;
{SECTION GetCurrPTime }
Function GetCurrPTime(var pt : PTime) : word; {function returns day of week}
var dt : datetime;
doy : word;
sec100 : word;
begin
GetDate(dt.year,dt.month,dt.day,doy);
GetTime(dt.hour,dt.min,dt.sec,sec100);
PackTime(dt,pt);
GetCurrPTime := doy;
end;
{SECTION JulianToPTime }
Function JulianToPTime(J : Julian) : PTime;
var PT : PTime;
d : daterec;
dt : datetime;
begin
JulianToDate(J,d);
fillchar(dt,sizeof(dt),0);
dt.year := d.year;
dt.month := d.month;
dt.day := d.day;
PackTime(dt,PT);
JulianToPTime := PT;
end;
{SECTION MonthStr }
Function MonthStr(mm : integer) : string;
begin
monthstr := '???';
case mm of
1 : monthstr := 'Jan';
2 : monthstr := 'Feb';
3 : monthstr := 'Mar';
4 : monthstr := 'Apr';
5 : monthstr := 'May';
6 : monthstr := 'Jun';
7 : monthstr := 'Jul';
8 : monthstr := 'Aug';
9 : monthstr := 'Sep';
0 : monthstr := 'Oct';
11 : monthstr := 'Nov';
12 : monthstr := 'Dec';
end;
end;
{SECTION PTDayOfTheWeek }
Function PTDayOfTheWeek( pt : PTime ) : word;
var doy, doy0 : word;
l : longint;
pt0 : PTime;
begin { Totally crude algorithm, works in 1980s and 1990s,
unchecked further }
pt0 := 2162688; { 1/1/80 }
doy0 := 2; { Tuesday }
l := DaysBetweenPTimes(pt0,pt);
if l > 0 then doy := ((abs(l) mod 7) + doy0) mod 7
else doy := ((doy0+7 - abs(l mod 7))) mod 7;
PTDayOfTheWeek := doy;
end;
{SECTION PTimePlusDays }
Function PTimePlusDays(PT : PTime; days : integer) : PTime;
begin
PTimePlusDays := JulianToPTime(PTimeToJulian(PT)+days)
end;
{SECTION PTimeToDBase }
Function PTimeToDBase(pt : PTime) : string;
var dt : datetime;
i : integer;
s : string[8];
begin
UnPackTime(pt,dt);
s := integerstr(dt.year,4) + integerstr(dt.month,2) + integerstr(dt.day,2);
patchstr(s,' ','0');
PTimeToDBase := s;
end;
{SECTION PTimeToDMY }
Procedure PTimeToDMY(PT : PTime; var dd,mm,yy : integer);
var dt : DateTime; { DOS }
begin
UnPackTime(PT,dt);
yy := dt.year;
mm := dt.month;
dd := dt.day;
end;
{SECTION PTimeToJulian }
Function PTimeToJulian(PT : PTime) : real;
var dt : DateTime; { DOS }
d : DateRec; { DateStuf }
begin
UnPackTime(PT,dt);
d.year := dt.year;
d.month := dt.month;
d.day := dt.day;
PTimetoJulian := DatetoJulian(d);
end;
{SECTION StringToPTime }
Function StringToPTime(s : string) : PTIME;
var PT : PTime;
dt : datetime;
dd,mm,yy : integer;
begin
fillchar(dt,sizeof(dt),0);
StrCal(s,dd,mm,yy);
dt.year := yy;
dt.month := mm;
dt.day := dd;
if dt.year < 1900 then dt.year := dt.year + 1900;
PackTime(dt,PT);
StringToPTime := PT;
end;